Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/toolkit/vbof_v11/vbofemgr.cls

Text File | 1996-03-01 | 13KB | 383 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "VBOFEventManager"
Attribute VB_Creatable = True
Attribute VB_Exposed = True
Option Explicit

' (c) Copyright 1995 Ken Fitzpatrick
'     All Rights Reserved
'     Cannot be distributed or sold without permission
'
' VBObjectFrameworkEventManager is a supplemental
'   Event Manager for Microsoft Visual Basic 4.0.
'   It is valid only in conjunction with the
'   following Classes Modules:
'       VBOFCollection
'       VBOFObjectLink
'       VBOFObjectManager
'       VBOFEventObject
'
' The VBOFEventManager interface, while
'   public, is not for public use.
'   VBOFEventManager is fully
'   encapsulated by VBOFObjectManager
'   and applications should use that interface
'   for all VBOFEventManager activity.
'
' See Class Module "VBOFObjectManager" for
'     documentation details

Private pvtObjectEvents As New Collection
Private pvtCollectionEvents As New Collection
Private pvtVBOFObjectManager As VBOFObjectManager

Private Const pvtReceiverDoesNotSupportThisMethod = 438

Public Property Get ObjectManager() As VBOFObjectManager
Attribute ObjectManager.VB_Description = "Private"
    Set ObjectManager = pvtVBOFObjectManager
End Property


Public Property Set ObjectManager(anObjectManager As VBOFObjectManager)
    Set pvtVBOFObjectManager = anObjectManager
End Property



Public Function ObjectID() As Long
Attribute ObjectID.VB_Description = "Private"
    ObjectID = -1
End Function



Public Function RegisterForObjectEvent(Optional TriggerObject As Variant, Optional TriggerObjectType As Variant, Optional TriggerEvent As Variant, Optional RegisterObject As Variant, Optional RegisterType As Variant, Optional SkipTriggerObject As Variant, Optional NewEventObject As Variant) As Boolean
Attribute RegisterForObjectEvent.VB_Description = "Private"
' Register the specified RegisterObject or
'   RegisterType to receive notification upon the
'   posting of the specified TriggerEvent by the
'   specified TriggerObject or TriggerObjectType

#If NoEventMgr = False Then
    Dim tempNewEventObject As New VBOFEventObject
    Dim tempEventObject As VBOFEventObject

    On Local Error Resume Next

' bullet-proofing
    If IsMissing(RegisterObject) And IsMissing(RegisterType) Then
        pvtErrorMessage TypeName(Me) & " cannot process the '.RegisterForObjectEvent' method for this object because the 'RegisterObject:=' and the 'RegisterType:=' parameters are missing.  At least one of these must be specified."
        RegisterForObjectEvent = False
        Exit Function
    End If
    If IsMissing(TriggerObject) And IsMissing(TriggerObjectType) Then
        If IsMissing(SkipTriggerObject) Or Not SkipTriggerObject Then
            pvtErrorMessage TypeName(Me) & " cannot process the '.RegisterForObjectEvent' method for this object because the 'TriggerObject:=' and the 'TriggerObjectType:=' parameters are missing.  At least one of these must be specified."
            RegisterForObjectEvent = False
            Exit Function
        End If
    End If

' initialize the EventObject
    If IsMissing(NewEventObject) Then
        Set tempEventObject = tempNewEventObject
    Else
        Set tempEventObject = NewEventObject
    End If
    Set tempEventObject.ObjectManager = pvtVBOFObjectManager

    If Not IsMissing(RegisterObject) Then
        Set tempEventObject.RegisterObject = _
            RegisterObject
    End If

    If Not IsMissing(RegisterType) Then
        tempEventObject.RegisterType = _
            RegisterType
    End If

    If Not IsMissing(TriggerObject) Then
        Set tempEventObject.TriggerObject = _
            TriggerObject
    End If

    If Not IsMissing(TriggerObjectType) Then
        tempEventObject.TriggerObjectType = _
            TriggerObjectType
    End If

    If Not IsMissing(TriggerEvent) Then
        tempEventObject.TriggerEvent = _
            TriggerEvent
    End If

' for internal re-use
    If Not IsMissing(SkipTriggerObject) Then
        If SkipTriggerObject = True Then    ' doesn't work when And-ed to above line
            Exit Function
        End If
    End If

    pvtObjectEvents.Add _
        tempEventObject
#End If

    RegisterForObjectEvent = True
End Function

Public Function RegisterForCollectionEvent(Optional Collection As Variant, Optional TriggerObject As Variant, Optional TriggerObjectType As Variant, Optional TriggerEvent As Variant, Optional RegisterObject As Variant, Optional RegisterType As Variant) As Boolean
Attribute RegisterForCollectionEvent.VB_Description = "Private"
' Register the specified RegisterObject or
'   RegisterType to receive notification upon the
'   posting of the specified TriggerEvent by the
'   specified TriggerObject or TriggerObjectType

#If NoEventMgr = False Then
    Dim tempNewEventObject As New VBOFEventObject

    On Local Error Resume Next

' bullet-proofing
    If IsMissing(RegisterObject) And IsMissing(RegisterType) Then
        pvtErrorMessage TypeName(Me) & " cannot process the '.RegisterForCollectionEvent' method for this object because the 'RegisterObject:=' and the 'RegisterType:=' parameters are missing.  At least one of these must be specified."
        RegisterForCollectionEvent = False
        Exit Function
    End If

' internal re-use
    RegisterForObjectEvent _
        TriggerObject:=TriggerObject, _
        TriggerObjectType:=TriggerObjectType, _
        TriggerEvent:=TriggerEvent, _
        RegisterObject:=RegisterObject, _
        RegisterType:=RegisterType, _
        NewEventObject:=tempNewEventObject, _
        SkipTriggerObject:=True

    If Not IsMissing(Collection) Then
        Set tempNewEventObject.Collection = _
            Collection
    End If

    pvtCollectionEvents.Add _
        tempNewEventObject
#End If

    RegisterForCollectionEvent = True
End Function

Public Function TriggerObjectEvent(Optional Event As Variant, Optional Object As Variant, Optional Verbose As Variant) As Boolean
Attribute TriggerObjectEvent.VB_Description = "Private"
' Trigger the specified Object Event.
' Post ObjectEventCallBack messages to each of the
'   registered objects

#If NoEventMgr = False Then
    Dim tempEventObject As Object
    Dim tempUCaseEvent As String

    On Local Error Resume Next

    TriggerObjectEvent = True
    tempUCaseEvent = UCase$(Event)

' check for the "Instantated" event, which should
'   be directed towards the new object
    If tempUCaseEvent = "INSTANTIATED" Then
        Object.ObjectEventCallBack _
            Event:=Event, _
            Object:=Object
        Exit Function
    End If

' process each of the EventObjects
    For Each tempEventObject In pvtObjectEvents

' if the event pertains to this EventObject
        If tempEventObject.IsRegisteredForEvent( _
            Event:=Event, _
            Object:=Object) _
        Then

' notify the registered object.
            tempEventObject.RegisterObject.ObjectEventCallBack _
                Event:=Event, _
                Object:=Object

' notify of the "missing method" condition
            If Err = pvtReceiverDoesNotSupportThisMethod Then
                If Not IsMissing(Verbose) Then
                    If Verbose <> False Then
                        pvtErrorMessage "Class Module '" & TypeName(tempEventObject.RegisterObject) & "' does not support the method 'ObjectEventCallBack'." & vbCrLf & "Object cannot be supported by " & TypeName(Me) & " without this method." & vbCrLf & "ObjectType=" & TypeName(tempEventObject.RegisterObject) & ", ObjectID=" & tempEventObject.RegisterObject.ObjectID
                    End If
                End If
            End If
        End If

    Next tempEventObject

    Set tempEventObject = Nothing
#End If
End Function

Public Function TriggerCollectionEvent(Optional Event As Variant, Optional Object As Variant, Optional Collection As Variant, Optional Verbose As Variant, Optional NoDelete As Variant) As Boolean
Attribute TriggerCollectionEvent.VB_Description = "Private"
' Trigger the specified Collection Event.
' Post ObjectEventCallBack messages to each of the
'   registered Collections

#If NoEventMgr = False Then
    Dim tempEventObject As Object
    Dim tempNoDelete As Boolean
    Dim I As Long

    On Local Error Resume Next

' bullet-proofing
'>>    If TypeName(Object) = "Error" Then
'        Exit Function
'    End If
    tempNoDelete = False
    If Not IsMissing(NoDelete) Then
        tempNoDelete = NoDelete
    End If

' process each of the EventObjects
    I = 1
    For Each tempEventObject In pvtCollectionEvents

' if the event pertains to this EventObject
        If tempEventObject.IsRegisteredForEvent( _
            Event:=Event, _
            Object:=Object, _
            Collection:=Collection, _
            IsCollectionEvent:=True _
        ) Then

' notify the registered object.
            tempEventObject.RegisterObject.ObjectEventCallBack _
                Event:=Event, _
                Object:=Object, _
                NoDelete:=tempNoDelete

' notify of the "missing method" condition
            If Err = pvtReceiverDoesNotSupportThisMethod Then
                If Not IsMissing(Verbose) Then
                    If Verbose <> False Then
                        pvtErrorMessage "Class Module '" & TypeName(tempEventObject.RegisterObject) & "' does not support the method 'ObjectEventCallBack'." & vbCrLf & "Object cannot be supported by " & TypeName(Me) & " without this method." & vbCrLf & "ObjectType=" & TypeName(tempEventObject.RegisterObject) & ", ObjectID=" & tempEventObject.RegisterObject.ObjectID
                    End If
                End If
            End If
        End If

        I = I + 1
    Next tempEventObject

    Set tempEventObject = Nothing
#End If
End Function



Private Function pvtErrorMessage(Optional ErrorMessage As Variant) As Long
    pvtErrorMessage = _
        pvtVBOFObjectManager.DisplayErrorMessage _
            (ErrorMessage)
End Function


Public Function UnRegisterForCollectionEvent(Optional RegisterObject As Variant, Optional CleanUpMode As Variant) As Boolean
Attribute UnRegisterForCollectionEvent.VB_Description = "Private"
' UnRegister the specified RegisterObject

    Dim tempEventObject As Object
    Dim tempObjectID As Long
    Dim I As Long

    On Local Error Resume Next

    If Not IsMissing(CleanUpMode) Then
        If CleanUpMode Then
            UnRegisterForCollectionEvent = True
            Exit Function
        End If
    End If

    I = 1
    For Each tempEventObject In pvtCollectionEvents

' if the RegisterObject doesn't have an ObjectID,
'   assume it's a Form and force the UnRegister to continue
        tempObjectID = tempEventObject.RegisterObject.ObjectID
        If Err = pvtReceiverDoesNotSupportThisMethod Then
            tempObjectID = RegisterObject.ObjectID
        End If

        If tempObjectID = RegisterObject.ObjectID Then
            If TypeName(tempEventObject.RegisterObject) = TypeName(RegisterObject) Then

                pvtCollectionEvents.Remove I
                Set tempEventObject = Nothing
                I = I - 1
            End If
        End If

        I = I + 1
    Next tempEventObject

    UnRegisterForCollectionEvent = True
    Set tempEventObject = Nothing
End Function


Public Function UnRegisterForObjectEvent(Optional RegisterObject As Variant, Optional CleanUpMode As Variant) As Boolean
Attribute UnRegisterForObjectEvent.VB_Description = "Private"
' UnRegister the specified RegisterObject

    Dim tempEventObject As Object
    Dim tempObjectID As Long
    Dim I As Long

    On Local Error Resume Next

' don't bother doing this during "CleanUpMode"
    If Not IsMissing(CleanUpMode) Then
        If CleanUpMode Then
            UnRegisterForObjectEvent = True
            Exit Function
        End If
    End If

    I = 1
    For Each tempEventObject In pvtObjectEvents

' if the RegisterObject doesn't have an ObjectID,
'   assume it's a Form and force the UnRegister to continue
        tempObjectID = tempEventObject.RegisterObject.ObjectID
        If Err = pvtReceiverDoesNotSupportThisMethod Then
            tempObjectID = RegisterObject.ObjectID
        End If

        If tempObjectID = RegisterObject.ObjectID Then
            If TypeName(tempEventObject.RegisterObject) = TypeName(RegisterObject) Then
                pvtObjectEvents.Remove I
                Set tempEventObject = Nothing
                I = I - 1
'               Exit Function
            End If
        End If

        I = I + 1
    Next tempEventObject

    UnRegisterForObjectEvent = True
    Set tempEventObject = Nothing
End Function